home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / back_end / reg.t < prev    next >
Encoding:
Text File  |  1990-06-19  |  16.1 KB  |  399 lines
  1. (herald (back_end reg)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define (generate-init continuation)
  30.   (bind ((*unit-literals* '())
  31.          (*unit-variables* '())
  32.          (*unit-closures* '())
  33.          (*unit-templates* '())
  34.          (*unit* nil) 
  35.          (*registers* (vector-fill (make-vector *no-of-registers*) nil))
  36.          (*lambda* nil)
  37.          (*stack-pos* 0)
  38.          (*locations* (make-table 'locations))
  39.          (*lambda-queue* '()))
  40.     (continuation)))
  41.  
  42.  
  43. (define (generate top-node)
  44.   (generate-code (car (call-args (lambda-body top-node)))))
  45.  
  46.  
  47. (lset *assembly-comments?* nil)
  48. (lset *lambda-queue* '())         ;; queue of lambda bodies to process
  49. (lset *stack-pos* 0)              ;; distance of stack-pointer from "frame"
  50. (lset *max-temp* 0)               ;; maximum number of temporaries used
  51. (lset *lambda* nil)               ;; the procedure being compiled
  52. (lset *call-break?* nil)           
  53. (lset *registers* nil)
  54.  
  55. (define-local-syntax (ass-comment string . rest)
  56.   `(if *assembly-comments?*
  57.        (emit-comment (format nil ,string ,@rest))))                      
  58.  
  59. ;;; GENERATE-CODE Initialize lambda queue. Go.
  60.  
  61. (define (generate-code node)
  62.   (set *stack-pos* 0)
  63.   (allocate-registers node)                                          
  64.   (process-lambda-queue))
  65.  
  66. (define (generate-code-for-object node)
  67.   (set *stack-pos* 0)            
  68.   (set *lambda* node)
  69.   (let ((object-proc ((call-arg 2) (lambda-body node))))
  70.     (mark-first-continuation (lambda-body object-proc))
  71.     (emit-template node object-proc)
  72.     (if (closure-env (environment-closure (lambda-env node)))
  73.         (mark (lambda-self-var node) P))
  74.     (mark-vars-in-regs (cdr (lambda-variables object-proc)))
  75.     (if (n-ary? object-proc)
  76.         (n-ary-setup object-proc))
  77.     (allocate-call (lambda-body object-proc))
  78.     (emit-tag object-proc))
  79.   (generate-handler node)
  80.   (process-lambda-queue))
  81.  
  82.  
  83. (define (lambda-queue node)
  84.   (push *lambda-queue* node))
  85.  
  86. (define (process-lambda-queue)
  87.   (if *lambda-queue*
  88.       (let ((thing (pop *lambda-queue*)))
  89.         (xcond ((object-lambda? thing)
  90.                 (generate-code-for-object thing))
  91.                ((lambda-node? thing)     
  92.                 (if (neq? (lambda-strategy thing) strategy/stack) 
  93.                     (mark-first-continuation (lambda-body thing)))
  94.                 (generate-code thing))
  95.                ((lap-template-struct? thing)
  96.                 (process-lap-template thing))))))
  97.  
  98. (define (mark-first-continuation node)
  99.   (walk mark-first-continuation-1 (call-proc+args node)))
  100.  
  101.  
  102. (define (mark-first-continuation-1 node)
  103.   (cond ((lambda-node? node)
  104.          (select (lambda-strategy node)
  105.            ((strategy/stack)
  106.             (set (closure-vframe-lambdas 
  107.                        (environment-closure (lambda-env node))) t))
  108.            ((strategy/open)                                        
  109.             (mark-first-continuation (lambda-body node)))))))
  110.  
  111. ;;; ALLOCATE-REGISTERS Sets *lambda* to be the lambda-node representing the
  112. ;;; environment the node argument is compiled in.  Generate code for the body.
  113.  
  114. (define (allocate-registers node)
  115.     (select (lambda-strategy node)
  116.       ((strategy/stack strategy/heap strategy/hack)
  117.        (set *lambda* node)
  118.        (emit-template node node))
  119.       ((strategy/vframe strategy/ezclose)
  120.        (set *lambda* (node-parent (node-parent node)))
  121.        (emit-tag node))
  122.       (else
  123.        (set *lambda* (variable-binder (join-point-contour (lambda-env node))))
  124.        (emit-tag node)))
  125.     (initialize-registers node)
  126.     (if (n-ary? node)
  127.         (n-ary-setup node))
  128.     (allocate-call (lambda-body node)))
  129.     
  130. ;;; INITIALIZE-REGISTERS Here we mark the arguments of a closure as being in
  131. ;;; the argument registers.  For a heaped lambda there is also the environment
  132. ;;; in the P register.  For a join point the state is initialized.
  133.  
  134. (define-integrable (method-lambda node)
  135.   (let ((p (node-parent node)))
  136.     (if (primop-ref? (call-proc p) primop/proc+handler)
  137.         (node-parent p)
  138.         nil)))
  139.    
  140. (define (initialize-registers node)
  141.   (xselect (lambda-strategy node)
  142.     ((strategy/heap strategy/hack)                                       
  143.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  144.              (lambda-name node)
  145.              (append! (map variable-unique-name (lambda-variables node))
  146.                       (cond ((lambda-rest-var node) => variable-unique-name)
  147.                             (else '()))))
  148.      (cond ((method-lambda node)
  149.             => (lambda (obj)
  150.                  (mark (lambda-self-var obj) P)
  151.                  (set *lambda* obj)))
  152.            (else
  153.             (mark (lambda-self-var node) P)))
  154.      (mark-vars-in-regs (cdr (lambda-variables node))))
  155.     ((strategy/stack)
  156.      (ass-comment "Continuation ~s (lambda ~s ...)"
  157.              (lambda-name node)
  158.              (append! (map variable-unique-name (lambda-variables node))
  159.                       (cond ((lambda-rest-var node) => variable-unique-name)
  160.                             (else '()))))
  161.      (mark-vars-in-regs (lambda-variables node)))
  162.     ((strategy/vframe)
  163.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  164.              (lambda-name node)
  165.              (map variable-unique-name (lambda-variables node)))
  166.      (mark (lambda-self-var *lambda*) P)
  167.      (mark-vars-in-regs (cdr (lambda-variables node))))
  168.     ((strategy/ezclose)
  169.      (ass-comment "Procedure ~s (lambda ~s ...)" 
  170.              (lambda-name node)
  171.              (map variable-unique-name (lambda-variables node)))
  172.      (mark-vars-in-regs (cdr (lambda-variables node))))
  173.     ((strategy/label)
  174.      (ass-comment "Label procedure ~s (lambda ~s ...)" 
  175.              (lambda-name node)
  176.              (map variable-unique-name (lambda-variables node)))
  177.      (cond ((join-point-contour-needed? (lambda-env node))
  178.             (let ((contour (join-point-contour (lambda-env node))))
  179.               (mark contour P)
  180.               (if (closure-cit-offset (environment-closure 
  181.                         (lambda-env (variable-binder contour))))
  182.                   (generate-move (reg-offset P -2) TP)))))
  183.      (walk (lambda (var arg-spec)
  184.              (mark var (car arg-spec)))
  185.           (if (continuation? node)
  186.               (lambda-variables node)
  187.               (cdr (lambda-variables node)))
  188.           (join-point-arg-specs (lambda-env node)))
  189.      (walk (lambda (pair)
  190.              (mark (cdr pair) (car pair)))
  191.            (join-point-global-registers (lambda-env node))))))
  192.  
  193.  
  194.  
  195. (define (mark-vars-in-regs vars)
  196.   (do ((vars vars (cdr vars))
  197.        (reg A1 (fx+ reg 1)))
  198.       ((or (fx>= reg AN) (null? vars))
  199.        (do ((vars vars (cdr vars))
  200.             (reg (fx+ reg (fx+ *argument-registers* 1)) (fx+ reg 1)))
  201.            ((null? vars))
  202.          (cond ((and (car vars) (variable-refs (car vars)))
  203.                 (mark-temp (car vars) reg)))))
  204.     (cond ((and (car vars) (variable-refs (car vars)))
  205.            (mark (car vars) reg)))))
  206.      
  207. ;;; A closure is n-ary if it has a non null rest arg.
  208.  
  209. (define n-ary? lambda-rest-var)
  210.  
  211. (define (n-ary-setup node)
  212.   (cond ((used? (lambda-rest-var node))
  213.          (generate-nary-setup node
  214.                               (if (eq? (lambda-strategy node) strategy/stack)
  215.                                   (length (lambda-variables node))
  216.                                   (length (cdr (lambda-variables node))))))))
  217.  
  218.  
  219.  
  220. (define (allocate-primop-call node)
  221.   (let* ((prim (primop-value (call-proc node))))
  222.     (cond ((primop.conditional? prim)
  223.            (allocate-conditional-primop node prim))
  224.           ((and (eq? prim primop/contents-location)
  225.                 (neq? (leaf-value ((call-arg 2) node)) primop/cell-value))
  226.            (allocate-location node prim))
  227.           ((primop.special? prim)
  228.            (primop.generate prim node))
  229.           (else           
  230.            (really-allocate-primop-call node prim)))))
  231.                                        
  232.  
  233. ;;; ALLOCATE-CONDITIONAL-PRIMOP When we come to a split we save the state of
  234. ;;; the world and traverse one arm, then restore the state and traverse the
  235. ;;; other.
  236.  
  237. (define (allocate-conditional-primop node prim)
  238.   (primop.generate prim node)      
  239.   (let ((then (then-cont node))
  240.         (else (else-cont node)))
  241.   (receive (then else) (cond ((or (leaf-node? then) 
  242.                                   (leaf-node? else) 
  243.                                   (fx< (lambda-trace then)
  244.                                        (lambda-trace else)))
  245.                               (return then else))
  246.                              (t
  247.                               (return else then)))
  248.     (bind ((*registers* (copy-registers))
  249.            (*stack-pos* *stack-pos*)
  250.            (*lambda* *lambda*)) 
  251.       (emit-tag then)  
  252.       (cond ((lambda-node? then)
  253.              (walk (lambda (n)
  254.                      (kill-if-dead n then))
  255.                    (cons else (cddr (call-args node))))
  256.              (allocate-call (lambda-body then)))
  257.             (t
  258.              (allocate-conditional-continuation node then)))
  259.       (return-registers))
  260.     (restore-slots)
  261.     (emit-tag else)  
  262.     (cond ((lambda-node? else)
  263.            (walk (lambda (n)
  264.                    (kill-if-dead n else))
  265.                  (cons then (cddr (call-args node))))
  266.            (allocate-call (lambda-body else)))
  267.           (t
  268.            (allocate-conditional-continuation node else))))))
  269.                                         
  270. ;; We must decide whether to try to delay dereferencing the location.
  271. ;; We do this if the value is used just once and in the next frob and
  272. ;; is an operand to a primop.
  273.  
  274. (define (allocate-location node prim)
  275.   (let ((c (cont node)))
  276.     (if (and (lambda-node? c)
  277.              (let ((refs (variable-refs (car (lambda-variables c)))))
  278.                (and refs
  279.                     (null? (cdr refs))
  280.                     (eq? c (node-parent (node-parent (car refs))))
  281.             (let ((proc (call-proc (lambda-body c))))
  282.               (and (primop-node? proc)
  283.                (neq? (primop-value proc) primop/make-cell)))
  284.                     (reps-compatable? 
  285.                       (primop.rep-wants (leaf-value ((call-arg 2) node)))
  286.                       (variable-rep (car (lambda-variables c)))))))
  287.         (generate-location-access node)
  288.         (really-allocate-primop-call node prim))))
  289.  
  290. (define (reps-compatable? accessor-rep use-rep)
  291.   (and (eq? (rep-size accessor-rep) (rep-size use-rep))
  292.        (not (rep-converter accessor-rep use-rep))))
  293.  
  294. (define (really-allocate-primop-call node prim)
  295.   (let ((c (cont node)))
  296.     (cond ((lambda-node? c)
  297.            (cond ((call-hoisted-cont node)
  298.                   => (lambda (cont)
  299.                        (walk (lambda (a-pair)
  300.                                (or (memq? (car a-pair) (lambda-live c))
  301.                                    (fx= (variable-number (car a-pair)) 0)
  302.                                    (any? (lambda (node)
  303.                                            (and (leaf-node? node)
  304.                                                 (eq? (leaf-value node) (car a-pair ))))
  305.                                          (cdr (call-args node)))
  306.                                    (kill (car a-pair))))
  307.                              (closure-env (environment-closure (lambda-env cont)))))) )
  308.            (primop.generate prim node)
  309.            (walk (lambda (node)
  310.                    (kill-if-dead node c))
  311.                  (cdr (call-args node)))
  312.            (allocate-call (lambda-body c)))
  313.           (else                            
  314.            (primop.generate prim node)
  315.            (walk (lambda (node)
  316.                    (if (leaf-node? node) (kill (leaf-value node))))
  317.                  (cdr (call-args node)))
  318.            (restore-continuation node c)
  319.            (clear-slots)
  320.            (let ((j (variable-known (leaf-value c))))
  321.              (if (and j (not (n-ary? j))) 
  322.                  (generate-jump j)
  323.                  (generate-return (primop.values-returned prim))))))))
  324.  
  325. (define (access/make-closure node lam)
  326.   (let* ((closure (environment-closure (lambda-env lam))))
  327.     (cond ((eq? closure *unit*)
  328.            (lambda-queue lam)
  329.            (lookup node lam nil))
  330.           (else
  331.            (make-heap-closure node closure)
  332.            nil))))
  333.  
  334.  
  335. (define-local-syntax (dotimes spec . body)
  336.   (let ((index (car spec))
  337.         (limit (cadr spec)))
  338.     `(do ((,index 0 (fx+ ,index 1)))
  339.          ((fx= ,index ,limit))
  340.        ,@body)))
  341.  
  342.  
  343. ;;; MAKE-STACK-CLOSURE Push a continuation on the stack.  For now there are no
  344. ;;; scratch values.  When there are we will need to push zeroes for all the
  345. ;;; scratch slots and fill them in after pushing the template.  This is because
  346. ;;; the GC assumes that anything on top of the stack until the first template
  347. ;;; is a valid pointer.
  348.  
  349. (define (make-stack-closure node cont)
  350.   (let* ((closure (environment-closure (lambda-env cont)))
  351.          (members (closure-members closure))
  352.          (a-list (cdr (closure-env closure))))
  353.     (walk (lambda (x)
  354.             (lambda-queue (variable-binder x)))
  355.           members)
  356.     (do ((i (closure-scratch closure) (fx- i 1)))
  357.         ((fx<= i 0))
  358.       (generate-push (machine-num 0)))
  359.     (walk (lambda (pair)                                          
  360.             (let ((var (car pair)))
  361.               (if (memq? var members)
  362.                   (generate-push-address (template (variable-binder var)))
  363.                   (generate-push (access-value node var)))))
  364.           (reverse! (sublist a-list 0 (closure-pointer closure))))
  365.     (generate-push-address (template cont))
  366.     (walk (lambda (pair)
  367.             (really-rep-convert node
  368.                                 (access-value node (car pair))
  369.                                 (variable-rep (car pair))
  370.                                 (reg-offset SP (cdr pair))
  371.                                 (variable-rep (car pair))))
  372.           (nthcdr a-list (closure-pointer closure)))))
  373.                                                             
  374.  
  375. (define (make-vframe-closure node l closure)
  376.   (walk lambda-queue (closure-vframe-lambdas closure))
  377.   (let ((a-list (cdr (closure-env closure))))
  378.     (do ((i (closure-scratch closure) (fx- i 1)))
  379.         ((fx<= i 0))
  380.       (generate-push (machine-num 0)))
  381.     (walk (lambda (pair)
  382.             (generate-push (access-value node (car pair))))
  383.           (reverse! (sublist a-list 0 (closure-pointer closure))))
  384.     (let ((closure (environment-closure (lambda-env l))))
  385.       (generate-push (machine-num (vframe-header (closure-pointer closure)
  386.                                                  (closure-scratch closure)))))
  387.     (walk (lambda (pair)
  388.             (really-rep-convert node
  389.                                 (access-value node (car pair))
  390.                                 (variable-rep (car pair))
  391.                                 (reg-offset SP (cdr pair))
  392.                                 (variable-rep (car pair))))
  393.           (nthcdr a-list (closure-pointer closure)))))
  394.                                                             
  395.   
  396. (define (vframe-header p s)
  397.   (+ (fixnum-ashl p 16) (fixnum-ashl s 8) header/vframe))
  398.  
  399.